Podział danych na arkusze i skoroszyty

Power Query jest narzędziem, które świetnie radzi sobie z łączeniem danych pochodzących z wielu źródeł. Często z jego wykorzystaniem łączymy podzielone dane znajdujące się w kilku arkuszach lub kilku skoroszytach. Co w sytuacji gdy chcemy przeprowadzić proces odwrotny do wspomnianego? Co gdy chcielibyśmy zrobić podział danych na arkusze i na skoroszyty? Tutaj Power Query nie będzie w stanie nam pomóc. Musimy posiłkować się makrami w VBA.
Kliknij aby przeczytać inne wpisy o Power Query.
Kliknij aby przeczytać inne wpisy o makrach VBA.

Podział danych na arkusze Excel

Nasza pojedyncza tabela z danymi, użyta na potrzeby tego wpisu, zawiera dane zgromadzone w 7miu kolumnach. Dla nas kluczowa będzie kolumna pierwsza zawierająca kolejne numery jednostek. Na jej podstawie będziemy chcieli przenieść makrem dane odpowiadające kolejnym jednostkom do osobnych arkuszy. Ilość wartości unikatowych w tej kolumnie to 4, odpowiadają kolejno jednostkom 101, 201, 301 i 401. W wyniku działania makra powinniśmy zatem otrzymać w skoroszycie 4 dodatkowe arkusze z podzielonymi danymi.

Makro będzie zaprogramowane w ten sposób, aby zmienne parametry można ustawić na jego początku – zaraz po zdefiniowaniu rodzajów zmiennych obiektowych. Dzięki temu kod można w łatwy sposób dostosować do tabeli składającej się z ilości kolumn innej niż 7. Odpowiednią zmienną ustawimy także kolumną wg której podział ma zostać przeprowadzony. Za to będzie odpowiadał poniższy fragment kodu razem z zadeklarowanymi zmiennymi typu Integer:
Dim intColumns As Integer
Dim intFilter As Integer
intColumns = 7 ' zmienna z ilością kolumn do skopiowania
intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć arkusze
W następnym kroku makra precyzujemy, w którym dokładnie arkuszu znajdują się nasze dane. Najczęściej będzie to arkusz pierwszy. Dodatkowo określamy maksymalną ilość wierszy w naszej bazie. Tutaj ustawiamy 900 000.
'zapamiętujemy sobie bieżący arkusz z danymi w zmiennej
Set shData = ThisWorkbook.Sheets(1)
'ile wierszy danych
lngLstRow = shData.Cells(900000, intFilter).End(xlUp).Row
Następnie makro musi określić nazwy naszych unikatów oraz ich ilość. Przeliczenie zajdzie w tymczasowym arkuszu, który zostanie dodany do naszego skoroszytu na czas działania makra. Na końcu będziemy go usuwać.
'Dodajemy arkusz na unikaty
Set shUnique = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'Tworzymy unikaty z naszej kolumny
shData.Columns(intFilter).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=shUnique.Range("A1"), Unique:=True
'Liczymy ile ich jest
lngLstUnique = shUnique.Range("A65536").End(xlUp).Row

Pętla For i / Next

Następny fragment kodu to tak naprawdę część najważniejsza, silnik całego makra. W obrębie pętli For i / Next najpierw przefiltrujemy i zdefiniujemy kolejne unikaty z naszego arkusza tymczasowego, a następnie odfiltrujemy je z tabeli bazowej oraz przekleimy do nowo powstałego arkusza, który otrzyma nazwę taką jak aktualnie wyfiltrowany unikat. Pętla będzie działać dopóki nie przejdzie przez wszystkie nasze unikaty. W naszym przykładzie będzie ich 4 ale z powodzeniem zadziała np. na 100 unikatach. Odbywa się to dzięki zmiennej lngLstUnique przechowującej ilość unikatów znajdujących się w naszej bazie.
'dla każdego unikatu
For i = 2 To lngLstUnique
With shData
'filtruj w/g unikatów
.Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text
' wybierz "przefiltrowane" komórki
Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible)
'utwórz nowy arkusz
Set shNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'przekopiuj do niego przefiltrowane dane
rngToCopy.Copy Destination:=Worksheets(Worksheets.Count).Range("A1")
'zmień nazwę arkusza
ActiveSheet.Name = shUnique.Range("A" & i).Text
End With
Next
Po przejściu pętli przez wszystkie unikaty i podzielenie naszych danych na arkusze makro wychodzi z pętli. Kolejnym krokiem jest usunięcie już niepotrzebnego tymczasowego arkusza z listą unikatów. Standardowo przy próbie skasowania arkusza Excel zawsze pyta użytkownika czy na pewno chce to zrobić. Aby nie zakłócać działania makra dodatkowymi MsgBoxami czasowo wyłączamy alerty Excela. Po usunięciu arkusza włączamy je ponownie. Ściągamy także filtr z naszej bazowej tabeli tak aby dane nie były zafiltrowane na ostatnim z naszych unikatów.
Application.DisplayAlerts = False
'usuwamy arkusz z unikatami
shUnique.Delete
Application.DisplayAlerts = True
'pokaż wszystkie dane w autofiltrze
shData.ShowAllData
Na samym końcu procedury dodajemy jeszcze tzw. czyszczenie, czyli zresetowanie wcześniej ustawionych zmiennych obiektowych. Pamiętamy także o obsłudze błędów. Warto w tym miejscu wspomnieć o poleceniu Application.ScreenUpdating. Dzięki niej zablokujemy przeskakiwanie okien co sprawi, że nasze makro nieco przyspieszy w działaniu. Będzie to szczególnie zauważalne przy większej ilości zmiennych unikatów.
W efekcie działania makra, w mgnieniu oka, dostajemy nowe arkusze z podzielonymi danymi. Wyobraźcie sobie stratę czasu gdyby tak przyszło Wam podzielić ręcznie np. 50 takich arkuszy 🙂

Całość procedury „Podziel na arkusze”

Sub Podziel_na_arkusze()
Dim shNew As Worksheet
Dim shUnique As Worksheet
Dim shData As Worksheet
Dim intColumns As Integer
Dim intFilter As Integer
Dim lngLstUnique As Long, lngLstRow As Long, i As Long
Dim rngToCopy As Range
On Error GoTo Podziel_na_arkusze_Error
'wyłączamy odświeżanie okien
Application.ScreenUpdating = False
' sprawy do ustawienia wg potrzeb
intColumns = 7 ' zmienna z ilością kolumn do skopiowania
intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć pliki
'zapamiętujemy sobie bieżący arkusz z danymi w zmiennej
Set shData = ThisWorkbook.Sheets(1)
'ile wierszy danych
lngLstRow = shData.Cells(900000, intFilter).End(xlUp).Row
'Dodajemy arkusz na unikaty
Set shUnique = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'Tworzymy unikaty z naszej kolumny
shData.Columns(intFilter).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=shUnique.Range("A1"), Unique:=True
'Liczymy ile ich jest
lngLstUnique = shUnique.Range("A65536").End(xlUp).Row
If lngLstUnique > 1 Then ' jeżeli jest choć jeden (oprócz nagłówka)
'dla każdego unikatu
For i = 2 To lngLstUnique
With shData
'filtruj w/g unikatów
.Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text
' wybierz "przefiltrowane" komórki
Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible)
'utwórz nowy arkusz
Set shNew = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'przekopiuj do niego przefiltrowane dane
rngToCopy.Copy Destination:=Worksheets(Worksheets.Count).Range("A1")
'zmień nazwę arkusza
ActiveSheet.Name = shUnique.Range("A" & i).Text
End With
Next
End If
Application.DisplayAlerts = False
'usuwamy arkusz z unikatami
shUnique.Delete
Application.DisplayAlerts = True
'pokaż wszystkie dane w autofiltrze
shData.ShowAllData
Clean:
'Sprzątanie
Set rngToCopy = Nothing
Set shNew = Nothing
Set shData = Nothing
Set shUnique = Nothing
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
'obsługa błędów
Podziel_na_arkusze_Error:
MsgBox "Bląd " & Err.Number & " (" & Err.Description & ") w procedurze Podziel_na_arkusze"
Resume Clean
End Sub

Podział danych na skoroszyty – osobne pliki .xlsx

Drugie makro również podzieli nasze dane, ale tym razem nie na arkusze, a na nowe skoroszyty, czyli de facto osobne pliki. Sam kod pozostanie bez większych zmian. Na początku makra musimy zdefiniować ścieżkę do folderu, w którym zapisywane będą nowe pliki po przeprowadzeniu podziału. Tutaj określamy ją jaką folder, w którym znajduje się nasz plik bazowy z tabelą do podziały. Zatem początkowy fragment kodu, po deklaracji zmiennych oraz włączaniu obsługi błędów, będzie wyglądał następująco:
' sprawy do ustawienia wg potrzeb
intColumns = 7 ' zmienna z ilością kolumn do skopiowania
intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć pliki
strPath = ThisWorkbook.Path & "" 'scieżka gdzie tworzymy pliki
W dalszej części kodu analogicznie jak poprzednio określamy arkusz bazowy, maksymalną ilość wierszy oraz tworzymy tymczasowy arkusz na unikaty.
Kilka zmian musimy zastosować natomiast w naszym silniku, czyli pętli For i / Next. W związku z podziałem na nowe pliki będziemy chcieli sprawdzić czy w folderze skoroszyt jaki chcemy utworzyć już przypadkiem nie istnieje. Dodatkowo kod zamiast dodawać arkusz jak poprzednio, będzie tworzył nowy skoroszyt Excel i do niego wklejał zafiltrowane dane. Przed wyjściem z pętli plik zostanie zapisany pod nazwą aktualnego unikatu oraz zamknięty.
For i = 2 To lngLstUnique
With shData
'filtruj w/g unikatów
.Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text
'sprawdzamy czy nie ma już pliku o nazwie pozycji z filtra
If Dir(strPath & shUnique.Range("A" & i).Text & ".xls") = "" Then
' wybierz "przefiltrowane" komórki
Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible)
'utwórz nowy skoroszyt
Set wkNew = Workbooks.Add
'przekopiuj do niego przefiltrowane dane
rngToCopy.Copy Destination:=wkNew.Worksheets(1).Range("A1")
'zapisz - jako nazwa pozycja filtra
wkNew.SaveAs Filename:=strPath & shUnique.Range("A" & i).Text
'zamknij
wkNew.Close
Else
MsgBox "Istnieje już plik " & strPath & shUnique.Range("A" & i).Text & ".xlsx"
End If
End With
Next
Po wyjściu z pętli, analogicznie jak poprzednio kasujemy tymczasowy arkusz na unikaty, resetujemy zmienne obiektowe, dodajemy obsługę błędów. W efekcie działania makra otrzymamy 4 nowe pliki umieszczone w folderze z naszym plikiem bazowym. Pliki z powodzeniem możemy udostępnić teraz np. naszym współpracownikom jednocześnie nie udostępniając im całej naszej bazy danych.

Pełna treść kodu VBA dla makra „Podziel na skoroszyty”

Sub Podziel_na_skoroszyty()
Dim wkNew As Workbook
Dim shUnique As Worksheet
Dim shData As Worksheet
Dim intColumns As Integer
Dim intFilter As Integer
Dim lngLstUnique As Long, lngLstRow As Long, i As Long
Dim strPath As String
Dim rngToCopy As Range
On Error GoTo Podziel_na_skoroszyty_Error
'wyłączamy odświeżanie okien
Application.ScreenUpdating = False
' sprawy do ustawienia wg potrzeb
intColumns = 7 ' zmienna z ilością kolumn do skopiowania
intFilter = 1 ' zmienna określająca, w/g której kolumny mamy tworzyć pliki
strPath = ThisWorkbook.Path & "" 'scieżka gdzie tworzymy pliki
'zapamiętujemy sobie bieżący arkusz z danymi w zmiennej
Set shData = ThisWorkbook.Sheets(1)
'ile wierszy danych
lngLstRow = shData.Cells(900000, intFilter).End(xlUp).Row
'Dodajemy arkusz na unikaty
Set shUnique = Worksheets.Add(After:=Worksheets(Worksheets.Count))
'Tworzymy unikaty z naszej kolumny
shData.Columns(intFilter).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=shUnique.Range("A1"), Unique:=True
'Liczymy ile ich jest
lngLstUnique = shUnique.Range("A65536").End(xlUp).Row
If lngLstUnique > 1 Then ' jeżeli jest choć jeden (oprócz nagłówka)
'dla każdego unikatu
For i = 2 To lngLstUnique
With shData
'filtruj w/g unikatów
.Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).AutoFilter Field:=intFilter, Criteria1:=shUnique.Range("A" & i).Text
'sprawdzamy czy nie ma już pliku o nazwie pozycji z filtra
If Dir(strPath & shUnique.Range("A" & i).Text & ".xls") = "" Then
' wybierz "przefiltrowane" komórki
Set rngToCopy = .Range(.Cells(1, 1), .Cells(lngLstRow, intColumns)).SpecialCells(xlCellTypeVisible)
'utwórz nowy skoroszyt
Set wkNew = Workbooks.Add
'przekopiuj do niego przefiltrowane dane
rngToCopy.Copy Destination:=wkNew.Worksheets(1).Range("A1")
'zapisz - jako nazwa pozycja filtra
wkNew.SaveAs Filename:=strPath & shUnique.Range("A" & i).Text
'zamknij
wkNew.Close
Else
MsgBox "Istnieje już plik " & strPath & shUnique.Range("A" & i).Text & ".xls"
End If
End With
Next
End If
Application.DisplayAlerts = False
'usuwamy arkusz z unikatami
shUnique.Delete
Application.DisplayAlerts = True
'pokaż wszystkie dane w autofiltrze
shData.ShowAllData
Clean:
'Sprzątanie
Set rngToCopy = Nothing
Set wkNew = Nothing
Set shData = Nothing
Set shUnique = Nothing
On Error GoTo 0
Application.ScreenUpdating = True
Exit Sub
'obsługa błędów
Podziel_na_skoroszyty_Error:
MsgBox "Bląd " & Err.Number & " (" & Err.Description & ") w procedurze Podziel_na_skoroszyty"
Resume Clean
End Sub